home *** CD-ROM | disk | FTP | other *** search
/ Programming Sound Cards / Programming Sound Cards.iso / sound_77 / soundx.prg < prev    next >
Encoding:
Text File  |  1995-01-01  |  5.0 KB  |  160 lines
  1. ****************************************************************************** 
  2. * Program Name: soundx.prg 
  3. * Coded by:     Richard R. Schafer 
  4. * 
  5. *   Produces a code based on the "Soundex" method originally developed 
  6. *       by M.K. Odell and R.C. Russell.  Algorithm can be found on page 
  7. *       392 of Knuths' book 'Sorting and Searching', volume 3 of 'The Art 
  8. *       of Computer Programming", Addison/Wesley publisher. 
  9. * 
  10. *   All non alphabetic characters and numbers are discarded.  Converts input 
  11. *       character string to uppercase and then procedes. 
  12. * 
  13. *   usage:  soundxx(gp_name) 
  14. * 
  15. *   gp_name = input character string on which soundex code is developed 
  16. * 
  17. ******************* RELEASED INTO THE PUBLIC DOMAIN ************************** 
  18.  
  19. FUNCTION soundxx 
  20.  
  21. parameters gp_name 
  22.  
  23. private pv_name_, pv_next, pv_code, pv_newname,pv_winscrn,pv_colorset 
  24. private pv_array,pv_arrayct,NULL 
  25.  
  26. *  this would probably be a global variable under normal usage 
  27. NULL = "" 
  28.  
  29. *  Set up way to get out if we didn't get any parameters, 
  30. *  as well as give the programmer a way to determine if 
  31. *  things went well 
  32. begin sequence 
  33.      *  did we get any parameters? 
  34.      if pcount() < 1 
  35.           set cursor off 
  36.  
  37.           *  save the screen window 
  38.           pv_winscrn = savescreen(08,10,13,69) 
  39.  
  40.           *  save the current screen attribs 
  41.           pv_colorset = setcolor() 
  42.           set color to "n/w,w+/n" 
  43.  
  44.           *  draw a box around the window 
  45.           @08,10 clear to 13,69 
  46.           @08,10 to 13,69 double 
  47.  
  48.           *  wait for user response 
  49.           @09,12 say "Usage:  soundxx(X_name)" 
  50.           @10,12 say "Where X_name is your variable containing the name" 
  51.           @11,12 say "you want a soundex code for" 
  52.           @12,12 say "PRESS ANY KEY TO CONTINUE" 
  53.           inkey(0) 
  54.           set cursor on 
  55.  
  56.           *  reset screen attribs 
  57.           set color to &pv_colorset 
  58.  
  59.           *  restore the screen 
  60.           restscreen(08,10,13,69,pv_winscrn) 
  61.  
  62.           *  return to calling function 
  63.           pv_code = .f. 
  64.  
  65.           *  and then break out of the sequence and return 
  66.           break 
  67.      endif 
  68.  
  69.      *  make sure everything is caps 
  70.      pv_newname = upper(gp_name) 
  71.       
  72.      *  set to the # char in the input character string 
  73.      pv_arrayct = len(rtrim(pv_newname)) 
  74.  
  75.      *  declare an array 
  76.      declare pv_name_[pv_arrayct] 
  77.  
  78.      * initialize a counter 
  79.      pv_array = 1 
  80.  
  81.      *  now we'll prepare the name string 
  82.      for pv_count = 1 to pv_arrayct 
  83.  
  84.           *  we'll eliminate everything that 
  85.           *  isn't an uppercase alpha character 
  86.           if asc(substr(pv_newname,pv_count,1)) < asc("A") .or.; 
  87.                asc(substr(pv_newname,pv_count,1)) > asc("Z") 
  88.           else 
  89.  
  90.                *  put it into our array 
  91.                *  increment the array counter 
  92.                pv_name_[pv_array] = substr(pv_newname,pv_count,1) 
  93.                pv_array = pv_array + 1 
  94.           endif 
  95.  
  96.      next 
  97.  
  98.      *  initialize the code holder 
  99.      pv_code = NULL 
  100.  
  101.      *  set to length of array 
  102.      pv_arrayct = len(pv_name_) 
  103.  
  104.      *  reset array counter 
  105.      pv_array = 1 
  106.  
  107.      *  put the 1st char into the code 
  108.      *  as is (not a number here) 
  109.      pv_code = pv_code + pv_name_[pv_array] 
  110.  
  111.      *  We'll stay in the loop 
  112.      *  until we fill the name string 
  113.      *  or until we hit the end of the array 
  114.      do while (len(pv_code)) < 4 .and. (pv_array < pv_arrayct) 
  115.  
  116.           *  increment array counter 
  117.           pv_array = pv_array + 1 
  118.  
  119.           do case 
  120.  
  121.                *  we skip these characters 
  122.                case pv_name_[pv_array] $ "AEHIOUWY" 
  123.  
  124.                *  and get numbers for the rest 
  125.                case pv_name_[pv_array] $ "BFPV" 
  126.                    pv_code = pv_code + "1" 
  127.                case pv_name_[pv_array] $ "CGJKQSXZ" 
  128.                    pv_code = pv_code + "2" 
  129.                case pv_name_[pv_array] $ "DT" 
  130.                    pv_code = pv_code + "3" 
  131.                case pv_name_[pv_array] $ "L" 
  132.                    pv_code = pv_code + "4" 
  133.                case pv_name_[pv_array] $ "MN" 
  134.                    pv_code = pv_code + "5" 
  135.                case pv_name_[pv_array] $ "R" 
  136.                    pv_code = pv_code + "6" 
  137.           endcase 
  138.  
  139.           * if we haven't gone beyond the end of the array 
  140.           if (pv_array + 1) < pv_arrayct 
  141.  
  142.                * is the next character the same 
  143.                * if it is, we'll skip it and 
  144.                * use the following character 
  145.                if pv_name_[pv_array] == pv_name_[pv_array + 1] 
  146.                    pv_array = pv_array + 1 
  147.                endif 
  148.  
  149.           endif 
  150.  
  151.      enddo 
  152.  
  153.      *  if the code isn't 4 characters long 
  154.      *  pad it with zeroes 
  155.      if len(pv_code) < 4 
  156.           pv_code = pv_code + replicate("0",4 - (len(pv_code))) 
  157.      endif 
  158. end sequence 
  159. return(pv_code) 
  160.